home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl.lha / akcl / V / c / structure.c < prev    next >
Text File  |  1989-11-30  |  13KB  |  688 lines
  1. Changes file for /usr/local/src/kcl/c/structure.c
  2. Created on Wed Nov 29 22:15:10 1989
  3. Usage \n@s[Original text\n@s|Replacement Text\n@s]
  4. See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
  5. for a program to merge change files.  Anything not between
  6. "\n@s[" and  "\n@s]" is a simply a comment.
  7. This file was constructed using emacs and  merge.el
  8. Enhancements Copyright (c) W. Schelter All rights reserved.
  9.    by (Bill Schelter)  wfs@carl.ma.utexas.edu 
  10.  
  11.  
  12. ****Change:(orig (15 17 d))
  13. @s[object siSstructure_print_function;
  14. object siSstructure_slot_descriptions;
  15. object siSstructure_include;
  16.  
  17. @s|
  18. @s]
  19.  
  20.  
  21. ****Change:(orig (18 18 a))
  22. @s[
  23.  
  24. @s|
  25. #define COERCE_DEF(x) if (type_of(x)==t_symbol) \
  26.   x=getf(x->s.s_plist,siLs_data,Cnil)
  27.  
  28. #define check_type_structure(x) \
  29.   if(type_of((x))!=t_structure) \
  30.     FEwrong_type_argument(Sstructure,(x)) 
  31.  
  32.  
  33.  
  34. @s]
  35.  
  36.  
  37. ****Change:(orig (22 31 c))
  38. @s[{
  39.     do {
  40.         if (type_of(x) != t_symbol)
  41.             return(FALSE);
  42.  
  43. @s,    } while (x != Cnil);
  44.     return(FALSE);
  45. }
  46.  
  47. @s|{ if (x==y) return 1;
  48.   if (type_of(x)!= t_structure
  49.       || type_of(y)!=t_structure)
  50.     FEerror("bad call to structure_subtypep",0);
  51.   {if (S_DATA(y)->included == Cnil) return 0;
  52.    while ((x=S_DATA(x)->includes) != Cnil)
  53.      { if (x==y) return 1;}
  54.    return 0;
  55.  }}
  56.  
  57. @s]
  58.  
  59.  
  60. ****Change:(orig (32 32 a))
  61. @s[
  62.  
  63. @s|
  64. static
  65. bad_raw_type()
  66. {           FEerror("Bad raw struct type",0);}
  67.  
  68.  
  69.  
  70. @s]
  71.  
  72.  
  73. ****Change:(orig (34 34 c))
  74. @s[structure_ref(x, name, n)
  75.  
  76. @s|structure_ref(x, name, i)
  77.  
  78. @s]
  79.  
  80.  
  81. ****Change:(orig (36 38 c))
  82. @s[object x, name;
  83. int n;
  84. {
  85.     int i;
  86.  
  87. @s|object x, name;
  88. int i;
  89. {unsigned short *s_pos;
  90.  COERCE_DEF(name);
  91.  if (type_of(x) != t_structure ||
  92.      (type_of(name)!=t_structure) ||
  93.      !structure_subtypep(x->str.str_def, name))
  94.    FEwrong_type_argument(name, x);
  95.  s_pos = &SLOT_POS(x->str.str_def,0);
  96.  switch((SLOT_TYPE(x->str.str_def,i)))
  97.    {
  98.    case aet_object: return(STREF(object,x,s_pos[i]));
  99.    case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
  100.    case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
  101.    case aet_bit:
  102.    case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
  103.    case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
  104.    case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
  105.    case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
  106.    case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
  107.    case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
  108.    default:
  109.      bad_raw_type();
  110.      return 0;
  111.    }}
  112.  
  113. @s]
  114.  
  115.  
  116. ****Change:(orig (40 43 c))
  117. @s[    if (type_of(x) != t_structure ||
  118.         !structure_subtypep(x->str.str_name, name))
  119.         FEwrong_type_argument(name, x);
  120.     return(x->str.str_self[n]);
  121.  
  122. @s|
  123. void
  124. siLstructure_ref1()
  125. {object x=vs_base[0];
  126.  int n=fix(vs_base[1]);
  127.  object def;
  128.  check_type_structure(x);
  129.  def=x->str.str_def;
  130.  if(n>= S_DATA(def)->length)
  131.    FEerror("Structure ref out of bounds",0);
  132.  vs_base[0]=structure_ref(x,x->str.str_def,n);
  133.  vs_top=vs_base+1;
  134.  
  135. @s]
  136.  
  137.  
  138. ****Change:(orig (45 45 a))
  139. @s[}
  140.  
  141.  
  142. @s|}
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149. @s]
  150.  
  151.  
  152. ****Change:(orig (47 47 c))
  153. @s[structure_set(x, name, n, v)
  154.  
  155. @s|structure_set(x, name, i, v)
  156.  
  157. @s]
  158.  
  159.  
  160. ****Change:(orig (49 51 c))
  161. @s[object x, name, v;
  162. int n;
  163. {
  164.     int i;
  165.  
  166. @s|object x, name, v;
  167. int i;
  168. {unsigned short *s_pos;
  169.  
  170.  COERCE_DEF(name);
  171.  if (type_of(x) != t_structure ||
  172.      type_of(name) != t_structure ||
  173.      !structure_subtypep(x->str.str_def, name))
  174.    FEwrong_type_argument(name, x);
  175.  
  176. @s]
  177.  
  178.  
  179. ****Change:(orig (53 57 c))
  180. @s[    if (type_of(x) != t_structure ||
  181.         !structure_subtypep(x->str.str_name, name))
  182.         FEwrong_type_argument(name, x);
  183.     x->str.str_self[n] = v;
  184.  
  185. @s,    return(v);
  186.  
  187. @s|#ifdef SGC
  188.  /* make sure the structure header is on a writable page */
  189.  if (x->d.m) FEerror("bad gc field"); else  x->d.m = 0;
  190. #endif   
  191.  
  192.  s_pos= & SLOT_POS(x->str.str_def,0);
  193.  switch(SLOT_TYPE(x->str.str_def,i)){
  194.    
  195.    case aet_object: STREF(object,x,s_pos[i])=v; break;
  196.    case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
  197.    case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
  198.    case aet_bit:
  199.    case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
  200.    case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
  201.    case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
  202.    case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
  203.    case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
  204.    case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
  205.  default:
  206.    bad_raw_type();
  207.  
  208.    }
  209.  return(v);
  210.  
  211. @s]
  212.  
  213.  
  214. ****Change:(orig (59 59 a))
  215. @s[}
  216.  
  217.  
  218. @s|}
  219.  
  220. void
  221. siLstructure_subtype_p()
  222. {object x,y;
  223.  check_arg(2);
  224.  x=vs_base[0];
  225.  y=vs_base[1];
  226.  if (type_of(x)!=t_structure)
  227.    {vs_base[0]=Cnil; goto BOTTOM;}
  228.  x=x->str.str_def;
  229.  COERCE_DEF(y);
  230.  if (structure_subtypep(x,y)) vs_base[0]=Ct;
  231.  else vs_base[0]=Cnil;
  232.  BOTTOM:
  233.  vs_top=vs_base+1;
  234. }
  235.  
  236.      
  237.  
  238.  
  239. @s]
  240.  
  241.  
  242. ****Change:(orig (64 64 a))
  243. @s[object x;
  244. {
  245.     object *p, s;
  246.  
  247. @s|object x;
  248. {
  249.     object *p, s;
  250.     struct s_data *def=S_DATA(x->str.str_def);
  251.  
  252. @s]
  253.  
  254.  
  255. ****Change:(orig (66 69 c))
  256. @s[
  257.     s = getf(x->str.str_name->s.s_plist,
  258.              siSstructure_slot_descriptions, Cnil);
  259.     vs_push(x->str.str_name);
  260.  
  261. @s|    
  262.     s = def->slot_descriptions;
  263.     vs_push(def->name);
  264.  
  265. @s]
  266.  
  267.  
  268. ****Change:(orig (72 72 c))
  269. @s[    for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
  270.  
  271. @s|    for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
  272.  
  273. @s]
  274.  
  275.  
  276. ****Change:(orig (75 75 c))
  277. @s[        *p = make_cons(x->str.str_self[i], Cnil);
  278.  
  279. @s|        *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
  280.  
  281. @s]
  282.  
  283.  
  284. ****Change:(orig (81 81 a))
  285. @s[    stack_cons();
  286.     return(vs_pop);
  287. }
  288.  
  289.  
  290. @s|    stack_cons();
  291.     return(vs_pop);
  292. }
  293.  
  294. void
  295.  
  296. @s]
  297.  
  298.  
  299. ****Change:(orig (84 85 c))
  300. @s[    object x;
  301.     int narg, i;
  302.  
  303. @s|  object x,name,*base;
  304.   struct s_data *def;
  305.   int narg, i,size;
  306.   base=vs_base;
  307.   if ((narg = vs_top - base) == 0)
  308.     too_few_arguments();
  309.   x = alloc_object(t_structure);
  310.   name=base[0];
  311.   COERCE_DEF(name);
  312.   if (type_of(name)!=t_structure  ||
  313.       (def=S_DATA(name))->length != --narg)
  314.     FEerror("Bad make_structure args for type ~a",1,
  315.         base[0]);
  316.   x->str.str_def = name;
  317.   x->str.str_self = NULL;
  318.   size=S_DATA(name)->size;
  319.   base[0] = x;
  320.   x->str.str_self = (object *)
  321.     (def->staticp == Cnil ? alloc_relblock(size)
  322.      : alloc_contblock(size));
  323.   /* There may be holes in the structure.
  324.      We want them zero, so that equal can work better.
  325.      */
  326.   if (S_DATA(name)->has_holes != Cnil)
  327.     bzero(x->str.str_self,size);
  328.   {unsigned char *s_type;
  329.    unsigned short *s_pos;
  330.    s_pos= (&SLOT_POS(x->str.str_def,0));
  331.    s_type = (&(SLOT_TYPE(x->str.str_def,0)));
  332.    base=base+1;
  333.    for (i = 0;  i < narg;  i++)
  334.      {object v=base[i];
  335.       switch(s_type[i]){
  336.          
  337.       case aet_object: STREF(object,x,s_pos[i])=v; break;
  338.       case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
  339.       case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
  340.       case aet_bit:
  341.       case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
  342.       case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
  343.       case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
  344.       case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
  345.       case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
  346.       case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
  347.       default:
  348.     bad_raw_type();
  349.  
  350. @s]
  351.  
  352.  
  353. ****Change:(orig (87 97 c))
  354. @s[    if ((narg = vs_top - vs_base) == 0)
  355.         too_few_arguments();
  356.     x = alloc_object(t_structure);
  357.     x->str.str_name = vs_base[0];
  358.  
  359. @s,        x->str.str_self[i] = vs_top[i];
  360.  
  361. @s|      }}
  362.    vs_top = base;
  363.    vs_base=base-1;
  364.  
  365.  }
  366.  
  367. @s]
  368.  
  369.  
  370. ****Change:(orig (99 99 a))
  371. @s[}
  372.  
  373.  
  374. @s|}
  375.  
  376. void
  377.  
  378. @s]
  379.  
  380.  
  381. ****Change:(orig (103 103 c))
  382. @s[    object x, y;
  383.     int i, j;
  384.  
  385. @s|    object x, y;
  386.     struct s_data *def;
  387.  
  388. @s]
  389.  
  390.  
  391. ****Change:(orig (105 105 c))
  392. @s[
  393.     check_arg(2);
  394.  
  395. @s|
  396.     if (vs_top-vs_base < 1) too_few_arguments();
  397.  
  398. @s]
  399.  
  400.  
  401. ****Change:(orig (107 110 c))
  402. @s[    if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
  403.         FEwrong_type_argument(vs_base[1], x);
  404.     vs_base[1] = y = alloc_object(t_structure);
  405.     y->str.str_name = x->str.str_name;
  406.  
  407. @s|    check_type_structure(x);
  408.     vs_base[0] = y = alloc_object(t_structure);
  409.     def=S_DATA(y->str.str_def = x->str.str_def);
  410.  
  411. @s]
  412.  
  413.  
  414. ****Change:(orig (112 116 c))
  415. @s[    y->str.str_length = j = x->str.str_length;
  416.     y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
  417.     for (i = 0;  i < j;  i++)
  418.         y->str.str_self[i] = x->str.str_self[i];
  419.  
  420. @s,    vs_base++;
  421.  
  422. @s|    y->str.str_self = (object *)alloc_relblock(def->size);
  423.     bcopy(x->str.str_self,y->str.str_self,def->size);
  424.     vs_top=vs_base+1;
  425.  
  426. @s]
  427.  
  428.  
  429. ****Change:(orig (118 118 a))
  430. @s[}
  431.  
  432.  
  433. @s|}
  434.  
  435. void
  436.  
  437. @s]
  438.  
  439.  
  440. ****Change:(orig (122 124 c))
  441. @s[    if (type_of(vs_base[0]) != t_structure)
  442.         FEwrong_type_argument(Sstructure, vs_base[0]);
  443.     vs_base[0] = vs_base[0]->str.str_name;
  444.  
  445. @s|    check_type_structure(vs_base[0]);
  446.     vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
  447.  
  448. @s]
  449.  
  450.  
  451. ****Change:(orig (126 126 a))
  452. @s[}
  453.  
  454.  
  455. @s|}
  456.  
  457. void
  458.  
  459. @s]
  460.  
  461.  
  462. ****Change:(orig (129 130 d))
  463. @s[siLstructure_ref()
  464. {
  465.     object x;
  466.     int i;
  467.  
  468. @s|siLstructure_ref()
  469. {
  470.  
  471. @s]
  472.  
  473.  
  474. ****Change:(orig (132 144 c))
  475. @s[
  476.     x = vs_base[0];
  477.     if (type_of(x) != t_structure ||
  478.         !structure_subtypep(x->str.str_name, vs_base[1]))
  479.  
  480. @s,    vs_base[0] = x->str.str_self[i];
  481.     vs_top = vs_base+1;
  482.  
  483. @s|    vs_base[0]=structure_ref(vs_base[0],vs_base[1],fix(vs_base[2]));
  484.     vs_top=vs_base+1;
  485.  
  486. @s]
  487.  
  488.  
  489. ****Change:(orig (146 146 a))
  490. @s[}
  491.  
  492.  
  493. @s|}
  494.  
  495. void
  496.  
  497. @s]
  498.  
  499.  
  500. ****Change:(orig (149 150 d))
  501. @s[siLstructure_set()
  502. {
  503.     object x;
  504.     int i;
  505.  
  506. @s|siLstructure_set()
  507. {
  508.  
  509. @s]
  510.  
  511.  
  512. ****Change:(orig (152 163 c))
  513. @s[
  514.     x = vs_base[0];
  515.     if (type_of(x) != t_structure ||
  516.         !structure_subtypep(x->str.str_name, vs_base[1]))
  517.  
  518. @s,    x->str.str_self[i] = vs_base[3];
  519.  
  520. @s|    structure_set(vs_base[0],vs_base[1],fix(vs_base[2]),vs_base[3]);
  521.  
  522. @s]
  523.  
  524.  
  525. ****Change:(orig (166 166 a))
  526. @s[    vs_base = vs_top-1;
  527. }
  528.  
  529.  
  530. @s|    vs_base = vs_top-1;
  531. }
  532.  
  533. void
  534.  
  535. @s]
  536.  
  537.  
  538. ****Change:(orig (227 227 a))
  539. @s[    vs_base[0] = l->c.c_car;
  540.     vs_pop;
  541. }
  542.  
  543.  
  544. @s|    vs_base[0] = l->c.c_car;
  545.     vs_pop;
  546. }
  547.  
  548.  
  549. siLmake_s_data_structure()
  550. {object x,y,raw,*base;
  551.  int i;
  552.  check_arg(5);
  553.  x=vs_base[0];
  554.  base=vs_base;
  555.  raw=vs_base[1];
  556.  y=alloc_object(t_structure);
  557.  y->str.str_def=y;
  558.  y->str.str_self = (object *)( x->v.v_self);
  559.  S_DATA(y)->name  =siLs_data;
  560.  S_DATA(y)->length=(raw->v.v_dim);
  561.  S_DATA(y)->raw   =raw;
  562.  for(i=3; i<raw->v.v_dim; i++)
  563.    y->str.str_self[i]=Cnil;
  564.  S_DATA(y)->slot_position=base[2];
  565.  S_DATA(y)->slot_descriptions=base[3];
  566.  S_DATA(y)->staticp=base[4];
  567.  S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
  568.  vs_base[0]=y;
  569.  vs_top=vs_base+1;
  570. }
  571.  
  572. void
  573. siLstructure_def()
  574. {check_arg(1);
  575.  check_type_structure(vs_base[0]);
  576.   vs_base[0]=vs_base[0]->str.str_def;
  577. }
  578.  
  579. short aet_sizes [] = {
  580. sizeof(object),  /* aet_object  t  */
  581. sizeof(char),  /* aet_ch  string-char  */
  582. sizeof(char),  /* aet_bit  bit  */
  583. sizeof(fixnum),  /* aet_fix  fixnum  */
  584. sizeof(float),  /* aet_sf  short-float  */
  585. sizeof(double),  /* aet_lf  long-float  */
  586. sizeof(char),  /* aet_char  signed char */
  587. sizeof(char),  /* aet_uchar  unsigned char */
  588. sizeof(short),  /* aet_short  signed short */
  589. sizeof(short)  /* aet_ushort  unsigned short   */
  590. };
  591.  
  592.   
  593.  
  594.  
  595.  
  596. void
  597. siLsize_of() 
  598. { object x= vs_base[0];
  599.   int i;
  600.   i= aet_sizes[get_aelttype(x)];
  601.   vs_base[0]=make_fixnum(i);
  602. }
  603.   
  604. void
  605. siLaet_type()
  606. {vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}
  607.  
  608.  
  609. /* Return N such that something of type ARG can be aligned on
  610.    an address which is a multiple of N */
  611.  
  612.  
  613. void
  614. siLalignment()
  615. {struct {double x; int y; double z;
  616.      float x1; int y1; float z1;}
  617.  joe;
  618.  joe.z=3.0;
  619.  
  620.  if (vs_base[0]==Slong_float)
  621.    {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
  622.  else
  623.    if (vs_base[0]==Sshort_float)
  624.      {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
  625.    else
  626.      {siLsize_of();}
  627. }
  628.    
  629.  
  630.  
  631.  
  632. @s]
  633.  
  634.  
  635. ****Change:(orig (230 238 c))
  636. @s[    siSstructure_print_function
  637.     = make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
  638.     enter_mark_origin(&siSstructure_print_function);
  639.     siSstructure_slot_descriptions
  640.  
  641. @s,    enter_mark_origin(&siSstructure_include);
  642.  
  643.  
  644. @s|        siLs_data=make_si_ordinary("S-DATA");
  645.  
  646. @s]
  647.  
  648.  
  649. ****Change:(orig (239 239 a))
  650. @s[    make_si_function("MAKE-STRUCTURE", siLmake_structure);
  651.  
  652. @s|    make_si_function("MAKE-STRUCTURE", siLmake_structure);
  653.     make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
  654.  
  655. @s]
  656.  
  657.  
  658. ****Change:(orig (242 242 a))
  659. @s[    make_si_function("STRUCTURE-REF", siLstructure_ref);
  660.  
  661. @s|    make_si_function("STRUCTURE-REF", siLstructure_ref);
  662.     make_si_function("STRUCTURE-DEF", siLstructure_def);
  663.     make_si_function("STRUCTURE-REF1", siLstructure_ref1);
  664.  
  665. @s]
  666.  
  667.  
  668. ****Change:(orig (245 245 c))
  669. @s[    make_si_function("STRUCTUREP", siLstructurep);
  670.  
  671.  
  672. @s|    make_si_function("STRUCTUREP", siLstructurep);
  673.     make_si_function("SIZE-OF", siLsize_of);
  674.     make_si_function("ALIGNMENT",siLalignment);
  675.     make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
  676.  
  677. @s]
  678.  
  679.  
  680. ****Change:(orig (247 247 a))
  681. @s[    make_si_function("LIST-NTH", siLlist_nth);
  682.  
  683. @s|    make_si_function("LIST-NTH", siLlist_nth);
  684.     make_si_function("AET-TYPE",siLaet_type);
  685.  
  686. @s]
  687.  
  688.